home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / tcl / tclmotif.1 / tclmotif / tm.1.2 / src / tmBasic.c < prev    next >
Encoding:
C/C++ Source or Header  |  1994-06-03  |  10.8 KB  |  402 lines
  1. /* 
  2.  * tmBasic.c --
  3.  *
  4.  *    Provides the support functions used by Tm_AppInit
  5.  *
  6.  * Copyright (c) 1993 J.D. Newmarch
  7.  *
  8.  * Copyright (c) 1993 The Regents of the University of California.
  9.  * All rights reserved.
  10.  *
  11.  * Permission is hereby granted, without written agreement and without
  12.  * license or royalty fees, to use, copy, modify, and distribute this
  13.  * software and its documentation for any purpose, provided that the
  14.  * above copyright notice and the following two paragraphs appear in
  15.  * all copies of this software.
  16.  * 
  17.  * IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY FOR
  18.  * DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT
  19.  * OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN IF THE UNIVERSITY OF
  20.  * CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
  21.  *
  22.  * THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES,
  23.  * INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
  24.  * AND FITNESS FOR A PARTICULAR PURPOSE.  THE SOFTWARE PROVIDED HEREUNDER IS
  25.  * ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION TO
  26.  * PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS.
  27.  */
  28.  
  29. #ifndef lint
  30. static char rcsid[] = "$Header";
  31. #endif /* not lint */
  32.  
  33. #include <tclXtSend.h>
  34. #include "tmFuncs.h"
  35.  
  36.  
  37.  
  38. /*
  39.  *----------------------------------------------------------------------
  40.  * Tm_Class -
  41.  *    The tcl source filename is used to construct the class name as
  42.  *    follows: a leading 'x' is capitalised and so is the following
  43.  *    character, else the leading char is capitalised
  44.  *
  45.  * Result
  46.  *    the class name as a new string
  47.  *
  48.  * Side effects
  49.  *    None
  50.  *----------------------------------------------------------------------
  51.  */
  52.  
  53. char *
  54. Tm_Class(interp)
  55.     Tcl_Interp *interp;
  56. {
  57.     char *path;
  58.     char *Class;
  59.  
  60.     path = Tcl_GetVar(interp, "argv0", TCL_GLOBAL_ONLY);
  61.  
  62.     Class = strrchr(path, '/');
  63.     if (Class == NULL)
  64.     Class = path;
  65.     else
  66.         Class++;
  67.  
  68.     Class = XtNewString(Class);
  69.     if (Class[0] == 'x') {
  70.     Class[0] = 'X';
  71.     if (Class[0] != '\0')
  72.         Class[1] = toupper(Class[1]);
  73.     } else
  74.     Class[0] = toupper(Class[0]);
  75.  
  76.     return Class;
  77. }
  78.  
  79. /*
  80.  *--------------------------------------------------------------
  81.  *
  82.  * Tm_RegisterSendCmd --
  83.  *    install the "send" command using the TclXtSend package
  84.  *    from yours truly
  85.  *
  86.  * Results:
  87.  *    none
  88.  *
  89.  * Side effects:
  90.  *    "send" and "interps" command added to interpreter
  91.  *    app name changed to <old-name> #N for some N if there 
  92.  *    is a clash with an existing interpreter
  93.  *--------------------------------------------------------------
  94.  */
  95.  
  96. static void
  97. Tm_RegisterSendCmd(interp, argv0, toplevel)
  98.     Tcl_Interp *interp;
  99.     String argv0;
  100.     Widget toplevel;
  101. {
  102.     String name, orig_name;
  103.     int n = 1;
  104.  
  105.     XtVaGetValues(toplevel, XmNtitle, &orig_name, NULL);
  106.     name = XtMalloc(strlen(orig_name) + 5);
  107.  
  108.     strcpy(name, orig_name);
  109.     while (TclXtSend_RegisterInterp(interp, name, toplevel) == TCL_ERROR) {
  110.     if (n > 99) {
  111.         XtAppErrorMsg(XtWidgetToApplicationContext(toplevel),
  112.         "Tm error", "can't register send", "TmError",
  113.         "can't register send command", NULL, 0);
  114.         XtFree(name);
  115.         return;;
  116.     }
  117.     n++;
  118.     sprintf(name, "%s #%d", orig_name, n);
  119.     }
  120.     XtVaSetValues(toplevel, XmNtitle, name, NULL);
  121.     XtFree(name);
  122. }
  123.  
  124. /*
  125.  *--------------------------------------------------------------
  126.  *
  127.  * Tm_SetOptions --
  128.  *
  129.  * Results:
  130.  *    builds an array of options.
  131.  *
  132.  * Side effects:
  133.  *    allocates memory for options array
  134.  *
  135.  *--------------------------------------------------------------
  136.  */
  137.  
  138. int
  139. Tm_SetOptions(interp, orig_opt, num_options, options)
  140.     Tcl_Interp *interp;
  141.     String orig_opt;
  142.     int *num_options;
  143.     XrmOptionDescRec **options;
  144. {
  145.     int n;
  146.     char **options_str;
  147.     int n_opt;
  148.     char **opt_str;
  149.  
  150.     Tcl_SplitList(interp, orig_opt, num_options, &options_str);
  151.     *options = (XrmOptionDescRec *) XtMalloc(*num_options * 
  152.                     sizeof(XrmOptionDescRec));
  153.     for (n = 0; n < *num_options; n++) {
  154.     Tcl_SplitList(interp, options_str[n], &n_opt, &opt_str);
  155.     if (n_opt != 3) {
  156.         sprintf(interp->result, "wrong options \"%50s\"", 
  157.                 options_str[n]);
  158.         return TCL_ERROR;
  159.     }
  160.     (*options)[n].option = opt_str[0];
  161.     (*options)[n].specifier = opt_str[1];
  162.     (*options)[n].value = NULL;
  163.     if (strcmp(opt_str[2], "noArg") == 0) {
  164.         (*options)[n].argKind = XrmoptionNoArg;
  165.         continue;
  166.     } else
  167.         if (strcmp(opt_str[2], "noArg") == 0) {
  168.             (*options)[n].argKind = XrmoptionNoArg;
  169.             continue;
  170.         } else
  171.         if (strcmp(opt_str[2], "isArg") == 0) {
  172.             (*options)[n].argKind = XrmoptionIsArg;
  173.             continue;
  174.         } else
  175.         if (strcmp(opt_str[2], "stickyArg") == 0) {
  176.             (*options)[n].argKind = XrmoptionStickyArg;
  177.             continue;
  178.         } else
  179.         if (strcmp(opt_str[2], "sepArg") == 0) {
  180.             (*options)[n].argKind = XrmoptionSepArg;
  181.             continue;
  182.         } else
  183.         if (strcmp(opt_str[2], "resArg") == 0) {
  184.             (*options)[n].argKind = XrmoptionResArg;
  185.             continue;
  186.         } else
  187.         if (strcmp(opt_str[2], "skipArg") == 0) {
  188.             (*options)[n].argKind = XrmoptionSkipArg;
  189.             continue;
  190.         } else
  191.         if (strcmp(opt_str[2], "skipNArgs") == 0) {
  192.             (*options)[n].argKind = XrmoptionSkipNArgs;
  193.             continue;
  194.         } else
  195.         if (strcmp(opt_str[2], "skipLine") == 0) {
  196.             (*options)[n].argKind = XrmoptionSkipLine;
  197.             continue;
  198.         } else {
  199.         sprintf(interp->result, "unknown option kind \"50s\"", opt_str[2]);
  200.         return TCL_ERROR;
  201.     }
  202.     }
  203.     return TCL_OK;
  204. }
  205.  
  206. /*
  207.  *----------------------------------------------------------------------
  208.  * Tm_AppInitialize -
  209.  *    start the Xt world
  210.  *
  211.  * Result
  212.  *    succeed or fail
  213.  *
  214.  * Side effects
  215.  *    The Xt world is started
  216.  *----------------------------------------------------------------------
  217.  */
  218.  
  219. int
  220. Tm_AppInitialize(clientData, interp, argc, argv)
  221.     ClientData clientData;
  222.     Tcl_Interp *interp;
  223.     int argc;
  224.     char *argv[];
  225. {
  226.     char *Class = NULL;
  227.     XtAppContext appContext;
  228.     Tm_Widget *wPtr;
  229.     static Tm_Display displayInfo;
  230.     XtActionsRec actions[2];
  231.     char *app_argv_str;
  232.     char **app_argv;
  233.     int app_argc = 0;
  234.     int old_app_argc;
  235.     XrmOptionDescRec *options = NULL;
  236.     int num_options = 0;
  237.     char **fallback_resources = NULL;
  238.     int num_fallback_resources;
  239.     char buf[128];
  240.     int n;
  241.     Widget toplevel;
  242.  
  243.     /* only allow this to start once */
  244.     if (Tcl_GetVar(interp, "_Tm_WorldInited", TCL_GLOBAL_ONLY) != NULL)
  245.      return TCL_OK;
  246.     Tcl_SetVar(interp, "_Tm_WorldInited", "1", TCL_GLOBAL_ONLY);
  247.  
  248.     /* restore the argv/arc pair - note that we have to bring argv0 in
  249.        or we don't get a suitable app name in app_argv[0]. We have to
  250.        copy the string from static as Tcl_Parse (tcl7.1, line 1214) writes
  251.        to it, crashing a Sun
  252.      */
  253.     strcpy(buf, "set _Tm_AllArgs [concat $argv0 $argv]");
  254.     Tcl_GlobalEval(interp, buf);
  255.     app_argv_str = Tcl_GetVar(interp, "_Tm_AllArgs", TCL_GLOBAL_ONLY);
  256.     Tcl_SplitList(interp, app_argv_str, &app_argc, &app_argv);
  257.     old_app_argc = app_argc;
  258.  
  259.     for (n = 1; n < argc; n++) {
  260.     if (argv[n][0] == '-') {
  261.         if (strcmp(argv[n], "-class") == 0) {
  262.         Class = XtNewString(argv[n+1]);
  263.         n++;
  264.         continue;
  265.         }
  266.         if (strcmp(argv[n], "-options") == 0) {
  267.         n++;
  268.         if (Tm_SetOptions(interp, argv[n], &num_options, &options) ==
  269.                 TCL_ERROR)
  270.             return TCL_ERROR;
  271.         continue;
  272.         }
  273.         if (strcmp(argv[n], "-fallbackResources") == 0) {
  274.         Tcl_SplitList(interp, argv[n+1], &num_fallback_resources,
  275.                 &fallback_resources);
  276.         n++;
  277.         continue;
  278.         }
  279.     }
  280.     }
  281.  
  282.     /* class set, or derive it from argv0? */
  283.     if (Class == NULL) 
  284.     Class = Tm_Class(interp);
  285.  
  286.     toplevel = XtAppInitialize (&appContext, Class, options, num_options,
  287.                 &app_argc, app_argv,
  288.                 fallback_resources, 
  289.                 NULL, 0);
  290.     XtFree(Class);
  291.  
  292.     /* did AppInit consume any args? If so, reset argv, argc */
  293.     if (app_argc != old_app_argc) {
  294.     char buffer[32], *args;
  295.  
  296.         args = Tcl_Merge(app_argc-1, app_argv+1);
  297.         Tcl_SetVar(interp, "argv", args, TCL_GLOBAL_ONLY);
  298.         ckfree(args);
  299.         sprintf(buffer, "%d", app_argc-1);
  300.         Tcl_SetVar(interp, "argc", buffer, TCL_GLOBAL_ONLY);
  301.     }
  302.  
  303.     /* register the actions handler */
  304.     actions[0].string = "exec";        /* for backward compatability */
  305.     actions[0].proc = Tm_ActionsHandler;
  306.  
  307.     actions[1].string = "action";
  308.     actions[1].proc = Tm_ActionsHandler;
  309.  
  310.     XtAppAddActions(appContext, actions, 2);
  311.  
  312.     displayInfo.commWidget = NULL;     /* this field is now redundant */
  313.     displayInfo.toplevel = toplevel;
  314.     displayInfo.display = XtDisplay(toplevel);
  315.  
  316.     wPtr = (Tm_Widget *) XtMalloc (sizeof (Tm_Widget));
  317.     wPtr -> interp = interp;
  318.     wPtr -> widget = toplevel;
  319.     wPtr -> pathName = XtNewString(".");
  320.     wPtr -> parent = ".";    /* kludge to stop later breakages */
  321.     wPtr -> displayInfo = &displayInfo;
  322.  
  323.     Tm_StoreWidgetInfo(".", wPtr, interp);
  324.  
  325.     Tcl_CreateCommand (interp, ".", Tm_RootCmd,
  326.                  (ClientData) wPtr, (void (*) ()) NULL);
  327.  
  328.     XtAddCallback(toplevel, XmNdestroyCallback, Tm_DestroyWidgetHandler, wPtr);
  329.  
  330.     Tm_RegisterConverters(interp, appContext);
  331.  
  332.     /* now try to create the "send" command */
  333.     Tm_RegisterSendCmd(interp, app_argv[0], toplevel);
  334.  
  335.     free((char *) app_argv);
  336.  
  337. #   ifdef MALLOC_TRACE
  338.     mal_leaktrace(1);
  339. #   endif
  340.  
  341.     return TCL_OK;
  342. }
  343.  
  344. /*
  345.  *----------------------------------------------------------------------
  346.  *
  347.  * Tm_Init --
  348.  *
  349.  *    This procedure performs initialization for the Tm extension.
  350.  *    Applications that wish to use tclMotif with other extensions
  351.  *    should include this procedure in TclAppInit along with the
  352.  *    other extensions.
  353.  *
  354.  * Results:
  355.  *    Returns a standard Tcl completion code, and leaves an error
  356.  *    message in interp->result if an error occurs.
  357.  *
  358.  * Side effects:
  359.  *    Creates the tclMotif commands in the interpreter.
  360.  *
  361.  *----------------------------------------------------------------------
  362.  */
  363. int
  364. Tm_Init (interp)
  365.     Tcl_Interp *interp;
  366. {
  367.     char *libDir;
  368.     char buf[32];
  369.  
  370.     /*
  371.      * Bind in Tm's commands.
  372.      */
  373.  
  374.     Tm_LoadWidgetCommands (interp);
  375.  
  376.     /* load the Xt commands */
  377.     Tcl_CreateCommand(interp, "xtAppInitialize", Tm_AppInitialize,
  378.             NULL, NULL);
  379.  
  380.     /*
  381.      * Set variables for the intepreter.
  382.      */
  383.  
  384.     libDir = getenv("TM_LIBRARY");
  385.     if (libDir == NULL) {
  386.     libDir = TM_LIBRARY;
  387.     }
  388.     Tcl_SetVar(interp, "tm_library", libDir, TCL_GLOBAL_ONLY);
  389.     Tcl_SetVar(interp, "tm_version", TM_VERSION, TCL_GLOBAL_ONLY);
  390.     Tcl_SetVar(interp, "tmVersion", TM_VERSION, TCL_GLOBAL_ONLY);
  391.  
  392.     /* Set Motif version info */
  393.     sprintf(buf, "%d", XmVERSION);
  394.     Tcl_SetVar(interp, "XmVERSION", buf, TCL_GLOBAL_ONLY);
  395.     sprintf(buf, "%d", XmVersion);
  396.     Tcl_SetVar(interp, "XmVersion", buf, TCL_GLOBAL_ONLY);
  397.     sprintf(buf, "%d", XmREVISION);
  398.     Tcl_SetVar(interp, "XmREVISION", buf, TCL_GLOBAL_ONLY);
  399.  
  400.     return TCL_OK;
  401. }
  402.